home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 2 / Tech Arsenal 2 (Arsenal Computer).iso / clipper / s93bsp.exe / CL5 / QBPROCS.PRG < prev    next >
Encoding:
Text File  |  1993-11-26  |  20.7 KB  |  849 lines
  1. ///////////////////////////////////////////////////////////////
  2. //
  3. //  Module : QBPROCS.PRG
  4. //
  5. //  Created by SUMMER'93 (c) on Fri Nov 26 14:49:59 1993
  6. //
  7. ///////////////////////////////////////////////////////////////
  8. #include "snj.ch"
  9. // The following statics were declared 'PUBLIC' in the S87 code
  10. // OR were private and inherited by called functions
  11. // If they are used outside this module there will be a set/get
  12. // function with the same name as the var in this module
  13. static PAGENO, PHEAD, PFOOT, PSTART, PDEST, LSTSUN
  14. procedure QBMESS( MSG, COLPARAM, WAITIME ) // Amended by SUMMER93
  15. // Calls: 
  16. // Called By: BODINDEX INVEDIT INVDEL INVREN QB2DATES QBMENU QBPRCTL QBADBLNK INVOUT QBTXTMAC QBINDATE BODARCH BODREST REPARAM INVVEH INVPAY INVINSLB NEWNUM 
  17. //   Q B M E S S . P R G
  18. // Print a MSG and wait for key stroke
  19. local MEM, GETLIST
  20. GETLIST := {}
  21.  
  22. //    Last change:  MIB  11 Aug 93    4:40 pm
  23.  
  24. do case 
  25.     case pcount( ) = 0 
  26.         MSG := "Press any key to continue..." 
  27.         COLPARAM := COLMENU() 
  28.         WAITIME :=  - 1 
  29.     case pcount( ) = 1 
  30.         COLPARAM := COLNORM() 
  31.         WAITIME := 0 
  32.     case pcount( ) = 2 
  33.         WAITIME := 0 
  34. endcase 
  35.  
  36. @ QBMSGLIN() , 0 clear to QBMSGLIN()  + 1, 79 
  37. set color to( COLPARAM )
  38. @ QBMSGLIN() , centre( trim(MSG ), 79 )say trim( MSG )
  39. set color to( COLNORM() )
  40. do case 
  41.     case WAITIME > 0 
  42.         inkey( WAITIME )
  43.         @ QBMSGLIN() , 0 clear to QBMSGLIN()  + 1, 79 
  44.     case WAITIME < 0 
  45.         set cursor off 
  46.         MEM := " " 
  47.         set color to( COLPWD() )
  48.         @ QBMSGLIN() , 0 get MEM 
  49.         read 
  50.         set color to( COLNORM() )
  51.         @ QBMSGLIN() , 0 clear to QBMSGLIN()  + 1, 79 
  52.         set cursor on 
  53. endcase 
  54.  
  55. return 
  56.  
  57. //*****************************************************************
  58.  
  59. procedure QBCLMESS
  60. // Calls: 
  61. // Called By: BODINDEX INVREN QBPROMPT QBREAD QBPRCTL QBGETD QBYESNO PARTPRMT QBDBCTRL BODARCH CTPRMT1 CTPRMT2 
  62. //       Q B C L M E S S
  63. //       Clear the message box
  64.  
  65. set color to( COLNORM() )
  66. @ QBMSGLIN() , 0 clear to QBMSGLIN()  + 1, 79 
  67.  
  68. return 
  69.  
  70. //*****************************************************************
  71.  
  72. function QBPROMPT( CMDS, MSG, CMDNO ) // Amended by SUMMER93
  73. // Calls: CHRCOUNT QBCLMESS ATNEXT 
  74. // Called By: INVMAIN INVEDIT INVADD QBPRCTL INVOUT QBPSETUP PARTUPDAT QBDBCTRL QBDBEXIT DRIVEOK REPMAIN REPARAM GINVNO CTUPDATE 
  75.  
  76. //   Q B P R O M P T . P R G
  77. //   Prompt user for single letter command
  78.  
  79. // The following locals have been declared by Summer'93
  80. // N1 N2 
  81. local NCMDS, COLNO, I, MCHR, N1, N2
  82.  
  83. N1 := 1 
  84. set message to QBMSGLIN()  + 1 center 
  85. if pcount( ) = 1 
  86.     MSG := "Select with first character, or " + chr( 27 ) + " " + chr( 26 ) + ;
  87.     " and ┘" 
  88. elseif pcount( ) = 2 
  89.     CMDNO := QBCHOICE() 
  90. endif 
  91. MCHR := "" 
  92.  
  93. NCMDS := CHRCOUNT( "|", CMDS )
  94. COLNO := centre( CMDS + space(NCMDS ), 79 )
  95.  
  96. clear typeahead 
  97. do QBCLMESS
  98. set color to( COLMENU() )
  99. for I := 1 to NCMDS 
  100.     N2 := ATNEXT( "|", CMDS, I )
  101.  
  102.     @ QBMSGLIN() , COLNO prompt substr( CMDS, N1, N2 - N1 )message MSG 
  103.     MCHR := MCHR + substr( CMDS, N1, 1 )
  104.     COLNO := col( ) + 2 
  105.     N1 := N2 + 1 
  106. next 
  107. menu to CMDNO 
  108. QBKEY( lastkey( ) )
  109. if CMDNO  = 0 
  110.     GETOUT( .t.  )
  111.     QBCHOICE( 0  )
  112.     QBRESP( "Q"  )
  113.     QBKEY( 27  )
  114. else 
  115.     QBRESP( substr( MCHR, CMDNO, 1 ) )
  116.     QBCHOICE( CMDNO  )
  117.     GETOUT( .f.  )
  118. endif 
  119. do QBCLMESS
  120.  
  121. return CMDNO 
  122.  
  123. //*****************************************************************
  124.  
  125. procedure QBBOX( WIDTH ) // Amended by SUMMER93
  126. // Calls: 
  127. // Called By: BODINDEX QBINIT HOUSEMAIN REPARAM BODYWORK 
  128.  
  129. // Q B B O X
  130. local ULINK, DLINK, RCOL, LCOL
  131.  
  132.  
  133. LCOL := ( 79  - WIDTH ) / 2 
  134. RCOL := 79  - LCOL 
  135. DLINK := chr( 209 )
  136. ULINK := chr( 207 )
  137. @ 3, LCOL say DLINK 
  138. @ 3, RCOL say DLINK 
  139. @ 4, LCOL to 20, LCOL 
  140. @ 4, RCOL to 20, RCOL 
  141. @ 21, LCOL say ULINK 
  142. @ 21, RCOL say ULINK 
  143.  
  144. return 
  145.  
  146. //*****************************************************************
  147.  
  148. procedure QBLAYOUT( HEADING ) // Amended by SUMMER93
  149. // Calls: 
  150. // Called By: BODINDEX QBINIT QBINDATE HOUSEMAIN REPARAM BODYWORK 
  151.  
  152. // Q B L A Y O U T
  153.  
  154. // layout  general header routine
  155.  
  156. clear screen
  157. // @  1,0 to 1,79 double
  158. @ 21, 0 to 21, 79 double 
  159. @ 23, 0 say QBTITLE() 
  160. @ 23, 80  - len( QBDATE() )say QBDATE() 
  161. @ 3, 0 to 3, 79 double 
  162. set color to( COLHEAD() )
  163. @ 22, centre( trim(HEADING ), 79 )say trim( HEADING )
  164. set color to( COLNORM() )
  165.  
  166. return 
  167.  
  168. //*****************************************************************
  169.  
  170. procedure QBREAD( MSG, MSG2, GETLIST ) // Amended by SUMMER93
  171. // Calls: QBCLMESS 
  172. // Called By: INVADD INVREN QB2DATES PARTGET PGETSPEC REPARAM INVGET INVVEH INVPAY INVINSLB GINVNO CTUPDATE 
  173. //  Q B R E A D
  174. //  Routine to check whether a bunch of fields have been modified
  175. local MPOS, MESS
  176.  
  177. MESS := trim( MSG ) + " - Hit Esc to Abort" 
  178. if pcount( )< 2 
  179.     MSG2 := "Move:  , End: ┘ (field), PgDn (screen)" 
  180. endif 
  181. do QBCLMESS
  182. set color to( COLBRIGHT() )
  183.  
  184. @ QBMSGLIN() , centre( trim(MESS ), 79 )say trim( MESS )
  185. if !empty( MSG2 )
  186.     @ QBMSGLIN()  + 1, centre( trim(MSG2 ), 79 )say trim( MSG2 )
  187. endif 
  188.  
  189. set color to( COLNORM() )
  190. read 
  191. GETOUT( ( lastkey() = 27 ) )
  192. CHANGED( updated( ) )
  193. do QBCLMESS
  194.  
  195. return 
  196.  
  197. //*****************************************************************
  198.  
  199. procedure QBPUTL( LSKIP, LINE ) // Amended by SUMMER93
  200. // Calls: QBYESNO 
  201. // Called By: REPLIST REPREV REPWIP 
  202.  
  203. //   Q B P U T L
  204. //   Used to output print lines and control page throws
  205. // The following locals have been declared by Summer'93
  206. // EXEC 
  207. local LCOUNT, PVAR, EXEC
  208.  
  209. LCOUNT := 1 
  210.  
  211. if GETOUT() 
  212.     return 
  213. endif 
  214. //   Public variable references (defined amd released in QBPRCTL):
  215.  
  216. //   PAGENO => current page number
  217. //   PLENGTH => no lines to page
  218. //   PLINE => current line no
  219. //   PHEAD1...PHEADn => header text lines for each page
  220. //   PHEADn that are missing become line feeds
  221. //   PHEAD => no header lines
  222. //   PDEST => Screen, Printer, File
  223. //   PFOOT1...PFOOTn => footer text lines for each page
  224. //   PFOOT => no footer lines
  225. if LINE  = "PLENGTH" 
  226.     PLENGTH( LSKIP  )
  227.     return 
  228. endif 
  229. if LINE  = "PWIDTH" 
  230.     PWIDTH( LSKIP  )
  231.     return 
  232. endif 
  233. if LINE  = "EJECT" 
  234.     PLINE( PLENGTH()  + 1  )
  235.     LINE := "" 
  236. endif 
  237.  
  238. //       End of Page
  239.  
  240. if( PLINE()  + LSKIP )> PLENGTH() 
  241.  
  242.     if !PSTART 
  243.         for LCOUNT := 1 to PFOOT 
  244.             PVAR := "PFOOT" + str( LCOUNT, 1 )
  245.             if  type( PVAR )<> "C"  // Did we define it?
  246.                 ?
  247.             else 
  248.                 EXEC := &PVAR 
  249.                 ?&EXEC  // Execute Macro for footer
  250.             endif 
  251.         next 
  252.         LCOUNT := 1 
  253.         do case 
  254.             case PDEST  = "S" 
  255.                 if QBYESNO( "Continue listing? (Y/N)" ) = "N" 
  256.                     GETOUT( .t.  )
  257.                     return 
  258.                 endif 
  259.                 clear screen
  260.                 @ 3, 0 say "" 
  261.             case PDEST  = "P" 
  262.                 eject 
  263.         endcase 
  264.     else 
  265.         if PDEST  = "S" 
  266.             clear screen
  267.             @ 3, 0 say "" 
  268.         endif 
  269.         PLENGTH( PLENGTH()  - ( PHEAD + PFOOT ) )
  270.         PSTART := .f. 
  271.     endif 
  272.  
  273.     do while LCOUNT <= PHEAD 
  274.         PVAR := "PHEAD" + str( LCOUNT, 1 )
  275.         if  type( PVAR )<> "C"  // Did we define it?
  276.             ?
  277.         else 
  278.             if len( &PVAR )< PWIDTH()  - 9 .and. LCOUNT  = 1 
  279.                 ?&PVAR + space( PWIDTH()  - 10  - len(PHEAD1() )) + "Page" + ;
  280.                 str( PAGENO, 4 )
  281.             else 
  282.                 ?&PVAR 
  283.             endif 
  284.         endif 
  285.         LCOUNT := LCOUNT + 1 
  286.     enddo 
  287.     PAGENO := PAGENO + 1 
  288.     PLINE( 0  )
  289.     LCOUNT := 1 
  290.  
  291. endif 
  292.  
  293. for LCOUNT := 1 to LSKIP 
  294.     ?
  295. next 
  296.  
  297. PLINE( PLINE()  + LSKIP  )
  298.  
  299. if len( LINE )> PWIDTH() 
  300.     LINE := substr( LINE, 1, PWIDTH() )
  301. endif 
  302.  
  303. ?? LINE 
  304.  
  305. return 
  306.  
  307. //*****************************************************************
  308.  
  309. procedure QBPUTH( HEADNO, HLINE ) // Amended by SUMMER93
  310. // Calls: 
  311. // Called By: REPLIST REPREV REPWIP 
  312.  
  313. //   Q B P U T H
  314. //   Used to define page headings
  315. local PVAR
  316.  
  317.  
  318. //   Public variable references:
  319.  
  320. //   PAGENO => current page number
  321. //   PLENGTH => no lines to page
  322. //   PLINE => current line no
  323. //   PHEAD1...PHEADn => header text lines for each page
  324. //   PHEAD => no header lines
  325. //   PDEST => Screen, Printer, File
  326.  
  327. PVAR := "PHEAD" + str( HEADNO, 1 )
  328. &PVAR := HLINE 
  329.  
  330. PHEAD := max( PHEAD + 1, HEADNO )
  331.  
  332. return 
  333.  
  334. //*****************************************************************
  335.  
  336. procedure QBPUTF( FOOTNO, FLINE ) // Amended by SUMMER93
  337. // Calls: 
  338. // Called By: 
  339.  
  340. //   Q B P U T F
  341. //   Used to define page and grand totals
  342. local PVAR
  343.  
  344.  
  345. //   Public variable references:
  346.  
  347. //   PAGENO => current page number
  348. //   PLENGTH => no lines to page
  349. //   PLINE => current line no
  350. //   PHEAD1...PHEADn => header text lines for each page
  351. //   PHEAD => no header lines
  352. //   PDEST => Screen, Printer, File
  353. //   PFOOT1...PFOOTn => footer text lines for each page
  354. //   PFOOT => np footer lines
  355.  
  356. PVAR := "PFOOT" + str( FOOTNO, 1 )
  357. &PVAR := FLINE 
  358.  
  359. PFOOT := FOOTNO 
  360.  
  361. return 
  362.  
  363. //*****************************************************************
  364.  
  365. procedure QBWIPE
  366. // Calls: 
  367. // Called By: INVDEL PARTDEL BODARCH 
  368.  
  369. //       QBWIPE
  370. //       Wipe out all the fields in a record
  371. // The following locals have been declared by Summer'93
  372. // DUMMY N I NULVAR CURFLD 
  373. local FNAME, FTYPE, FWIDTH, DUMMY, N, I, NULVAR, CURFLD
  374. DUMMY := "" 
  375. N := fcount( )
  376. FNAME := array(  N  )
  377. FTYPE := array(  N  )
  378. FWIDTH := array(  N  ) 
  379.  
  380. afields( FNAME, FTYPE, FWIDTH, DUMMY )
  381.  
  382. for I := 1 to N 
  383.  
  384.     do case 
  385.         case FTYPE[ I ] $ "CM" 
  386.             NULVAR := " " 
  387.         case FTYPE[ I ]  = "D" 
  388.             NULVAR := ctod( "" )
  389.         case FTYPE[ I ]  = "N" 
  390.             NULVAR := 0 
  391.         case FTYPE[ I ]  = "L" 
  392.             NULVAR := .f. 
  393.     endcase 
  394.     CURFLD := FNAME[ I ] 
  395.     replace &CURFLD with NULVAR 
  396. next 
  397.  
  398. return 
  399.  
  400. //*****************************************************************
  401.  
  402. procedure QB2DATES( MESS, R1, C1, D1, R2, C2, D2 ) // Amended by SUMMER93
  403. // Calls: QBREAD QBMESS 
  404. // Called By: BODARCH REPARAM 
  405.  
  406. //       Q B 2 D A T E S
  407. //       get two dates if one is blank  set limits..
  408. local GETLIST
  409. GETLIST := {}
  410. if D1  = ctod( "01/1/87" )
  411.     D1 := ctod( "" )
  412. endif 
  413. if D2  = ctod( "31/12/99" )
  414.     D2 := ctod( "" )
  415. endif 
  416.  
  417. do while .t. 
  418.     @ R1, C1 get D1 picture "@K" 
  419.     @ R2, C2 get D2 picture "@K" 
  420.     do QBREAD with MESS , , @GETLIST
  421.     // Call amended
  422.  
  423.     if D2  = ctod( "" )
  424.         D2 := ctod( "31/12/99" )
  425.     endif 
  426.  
  427.     do case 
  428.         case GETOUT() 
  429.             exit 
  430.         case D1 > D2 
  431.             do QBMESS with "First date is after Second", COLFLASH() , 3 
  432.         case D1  = ctod( "" )
  433.             D1 := ctod( "01/01/87" )
  434.             exit 
  435.         otherwise 
  436.             exit 
  437.     endcase 
  438. enddo 
  439.  
  440. return 
  441.  
  442. //*****************************************************************
  443.  
  444. function QBMENU( MENUNAME, WIDTH ) // Amended by SUMMER93
  445. // Calls: QBMESS 
  446. // Called By: HOUSEMAIN BODYWORK 
  447.  
  448. //   Q B M E N U . P R G
  449. // Procedure to get menu choice from user -
  450. // returns both keystroke and choice no.
  451. local SCOL, MROW, MAXLEN, LPOS, CPOS, NCHAR, m, I
  452. // These locals cover set/get variables where lvalues are needed
  453. local QBCHOICE
  454.  
  455. SCOL := 5  + ( 79  - WIDTH ) / 2 
  456. MROW := 8 
  457. MAXLEN := 0 
  458. I := 0 
  459. LPOS := 1 
  460. QBKEY( 0  )
  461. if QBCHOICE()  = 0 
  462.     QBCHOICE( 1  )
  463. endif 
  464.  
  465. // SET exact off
  466. set message to 1 center 
  467. // SELECT 9
  468. set color to( COLMENU() )
  469. use QBINFO index QBINFO 
  470. set softseek on 
  471. seek trim( MENUNAME )
  472. if  !eof( )
  473.     do while( substr(FIELD->qbinfkey , 1, 7 ) = MENUNAME ) .and.(  !eof())
  474.         I := I + 1 
  475.         @ MROW, SCOL prompt trim( FIELD->QBTEXT )message trim( ;
  476.         FIELD->WHATITDOES )
  477.         MROW := MROW + 1 
  478.         skip 
  479.     enddo 
  480. endif 
  481. if I  = 0 
  482.     do QBMESS with "No valid menu choices available", COLFLASH() , 5 
  483.     QBKEY( 27  )
  484.     QBCHOICE( 0  )
  485.     use 
  486.     return 0 
  487. else 
  488.     menu to QBCHOICE 
  489.     QBCHOICE(QBCHOICE)
  490.     seek substr( MENUNAME, 1, 7 ) + str( QBCHOICE() , 1 )
  491.     QBPROC( FIELD->QBTEXT  )
  492.     use 
  493. endif 
  494. if QBCHOICE()  = 0 
  495.     QBKEY( 27  )
  496. endif 
  497. set softseek off 
  498.  
  499. set color to( COLNORM() )
  500. // SET exact on
  501.  
  502. return QBCHOICE() 
  503.  
  504. //*****************************************************************
  505.  
  506. procedure QBPRCTL( CHOICE ) // Amended by SUMMER93
  507. // Calls: QBPROMPT QBMESS QBCLMESS 
  508. // Called By: INVOUT REPARAM REPLIST REPREV REPWIP 
  509.  
  510. //     Q B P R C T L
  511. //     Control Printing
  512. // The following locals have been declared by Summer'93
  513. // FNAME ACTION 
  514. local GETLIST, FNAME, ACTION
  515. GETLIST := {}
  516. FNAME := space( 8 )
  517. PAGENO := 1 
  518. PHEAD := 0 
  519. PFOOT := 0 
  520. PSTART := .t. 
  521.  
  522. if GETOUT() 
  523.     close database 
  524.     return 
  525. endif 
  526.  
  527. // If the choice is specified it just goes ahead and does it using the last part
  528. // of choice as the file name, if not you are asked which to use if it's a file
  529. // then you are prompted for the name.
  530.  
  531. do case 
  532.     case len( trim(CHOICE )) = 0 
  533.         PDEST := " " 
  534.         set console on 
  535.         set alternate off 
  536.         CHOICE := substr( "SPFQ", QBPROMPT("Screen|Printer|File|Quit|", ;
  537.         "Choose output destination", 1 ), 1 )
  538.         if CHOICE  = "Q" 
  539.             GETOUT( .t.  )
  540.             return 
  541.         endif 
  542.     case len( trim(CHOICE ))> 2 
  543.         FNAME := substr( CHOICE, 3, len(CHOICE ) - 2 )
  544. endcase 
  545.  
  546. CHOICE := substr( CHOICE, 1, 1 )
  547. if CHOICE $ "PSF" 
  548.     PDEST := CHOICE 
  549.     do case 
  550.         case CHOICE  = "S" 
  551.             PLENGTH( 22  )
  552.             PWIDTH( 79  )
  553.         otherwise 
  554.             PLENGTH( 55  )
  555.             PWIDTH( 132  )
  556.     endcase 
  557.     PLINE( PLENGTH()  + 1  )
  558.     PHEAD := 0 
  559. endif 
  560.  
  561. do case 
  562.     case CHOICE  = "S" 
  563.         do QBMESS with "Preparing Report", COLFLASH() , 0 
  564.     case CHOICE  = "P" 
  565.         do QBMESS with "Printing Report", COLFLASH() , 0 
  566.         do while !isprinter( )
  567.             ACTION := QBPROMPT( "Continue|Quit|", ;
  568.             "Printer is not ready - correct and continue or Quit", 1 )
  569.             if ACTION  = 2 .or. QBRESP()  = "Q" 
  570.                 GETOUT( .t.  )
  571.                 return 
  572.             endif 
  573.         enddo 
  574.         set print on 
  575.         set console off 
  576.         ?TPSET1()  // Begin print code
  577.     case CHOICE  = "F" 
  578.         if len( CHOICE )> 1 
  579.             FNAME := trim( substr(CHOICE, 3, len(CHOICE - 2 )))
  580.         else 
  581.             do QBCLMESS
  582.             @ QBMSGLIN() , 26 say "Enter file name: " get FNAME picture ;
  583.             "NNNNNNNN" 
  584.             read 
  585.         endif 
  586.         if !"." $ FNAME 
  587.             FNAME := upper( trim(FNAME )) + ".TXT" 
  588.         endif 
  589.         do QBMESS with "Sending Report to file " + FNAME, COLFLASH() , 0 
  590.         set alternate to  ( FNAME ) 
  591.         set console off 
  592.         set alternate on 
  593.     case CHOICE  = "R"  // Reset
  594.         set print off 
  595.         set console on 
  596.         
  597.         PHEAD1( ""  )
  598.         PHEAD2( ""  )
  599.         PHEAD3( ""  )
  600.         PHEAD4( ""  )
  601.         PHEAD5( ""  )
  602.         PHEAD6( ""  )
  603.         PHEAD7( ""  )
  604.         PHEAD8( ""  )
  605.         PHEAD9( ""  )
  606.         do case 
  607.             case PDEST  = "F" 
  608.                 ?
  609.                 set alternate off 
  610.                 close alternate 
  611.             case PDEST  = "P" 
  612.                 set console off 
  613.                 eject 
  614.                 set console on 
  615.                 set print off 
  616.             case PDEST  = "S" 
  617.                 ?
  618.                 ?
  619.         endcase 
  620.         do QBMESS with FNAME + " - Press a key", COLMENU() ,  - 1 
  621.         do QBCLMESS
  622. endcase 
  623. TPSET1( PSET2()  )  // reset to system defaults
  624. return 
  625.  
  626. //*****************************************************************
  627.  
  628. procedure QBLSTSUN
  629. // Calls: 
  630. // Called By: QBINDATE 
  631. //       Q B L S T S U N . P R G
  632. //       Find the date last Sunday
  633.  
  634. LSTSUN := date( ) - dow( date()) + 1 
  635.  
  636. return 
  637.  
  638. //*****************************************************************
  639.  
  640. procedure QBGETD( MSG, default ) // Amended by SUMMER93
  641. // Calls: QBCLMESS 
  642. // Called By: QBINDATE 
  643. //       Q B G E T D . P R G
  644. // get a date variable: qbrespd
  645.  
  646. local MPOS, GETLIST
  647. // These locals cover set/get variables where lvalues are needed
  648. local QBRESPD
  649. GETLIST := {}
  650.  
  651. MPOS := ( 79  - len(MSG )) / 2 
  652. QBRESPD( ctod( default ) )
  653.  
  654. set confirm on 
  655. do QBCLMESS
  656. // GET command amended to ...
  657. QBRESPD := QBRESPD()
  658. @ QBMSGLIN() , MPOS  say MSG  get QBRESPD ;
  659.  WHEN { || QBRESPD := QBRESPD(), .t. }  valid { || ;
  660.  QBRESPD( QBRESPD ) != NIL }
  661. read 
  662. set confirm off 
  663.  
  664. return 
  665.  
  666. //*****************************************************************
  667.  
  668. function QBYESNO( MSG ) // Amended by SUMMER93
  669. // Calls: QBCLMESS 
  670. // Called By: BODINDEX INVDEL INVREN QBPUTL INVOUT PARTUPDAT BODARCH BODREST INVGET INVVEH INVPAY INVINSLB GINVNO CTSLCT CTUPDATE BODYWORK IVFUNC 
  671. local RETVAL
  672.  
  673.  
  674. do QBCLMESS
  675. set color to( COLBRIGHT() )
  676. set cursor off 
  677. @ QBMSGLIN() , centre( trim(MSG ), 79 )say trim( MSG )
  678.  
  679. RETVAL := " " 
  680. do while !RETVAL $ "YN" 
  681.     RETVAL := upper( chr(inkey()))
  682. enddo 
  683. do QBCLMESS
  684. set cursor on 
  685.  
  686. return RETVAL 
  687.  
  688. //*****************************************************************
  689.  
  690. function centre( CTEXT, WIDTH ) // Amended by SUMMER93
  691. // Calls: 
  692. // Called By: 
  693. //       Returns column position for Centred heading
  694. // The following locals have been declared by Summer'93
  695. // COLPOS 
  696. local COLPOS
  697.  
  698. if pcount( ) = 1 
  699.     WIDTH := 80 
  700. endif 
  701.  
  702. COLPOS := max( int((WIDTH - 1  - len(CTEXT )) / 2 ), 0 )
  703.  
  704. return COLPOS 
  705.  
  706. //*****************************************************************
  707.  
  708. procedure QBADBLNK( NRECS ) // Amended by SUMMER93
  709. // Calls: QBMESS 
  710. // Called By: INVSAVE PARTSAVE 
  711.  
  712. //   Q B A D B L N K . P R G
  713. // Routine to append blank records
  714. local I, ADSTR
  715.  
  716.  
  717. // i = recsize()*nrecs
  718. // IF i>diskspace()
  719. //     adstr = "You have run out of disc space!!"
  720. //     DO qbmess WITH adstr,colflash,0
  721. //     WAIT
  722. //    DO qbquit
  723. // ENDIF
  724.  
  725. ADSTR := "Please wait - adding " + str( NRECS, 4 ) + " records" 
  726.  
  727. do QBMESS with ADSTR, COLFLASH() , 0 
  728.  
  729. I := 1 
  730. do while I <= NRECS 
  731.     I := I + 1 
  732.     append blank 
  733. enddo 
  734. do QBMESS with " ", COLNORM() , 0 
  735.  
  736. return 
  737.  
  738. //*****************************************************************
  739. function SEEKIT( CTEXT ) // Amended by SUMMER93
  740. // Calls: 
  741. // Called By: 
  742. seek CTEXT 
  743. return(  !eof())
  744.  
  745. //******************************************************************
  746. function blank( XVALUE ) // Amended by SUMMER93
  747. // Calls: 
  748. // Called By: 
  749. local XRETURN
  750.  
  751.  
  752. do case 
  753.     case valtype( xValue ) == "C" 
  754.         XRETURN := space( len(XVALUE ))
  755.     case valtype( xValue ) == "N" 
  756.         XRETURN := 0 
  757.     case valtype( xValue ) == "L" 
  758.         XRETURN := .f. 
  759.     case valtype( xValue ) == "D" 
  760.         XRETURN := ctod( "" )
  761. endcase 
  762.  
  763. return XRETURN 
  764.  
  765. //******************************************************************
  766. function CHRCOUNT( CCHAR, CSTRING ) // Amended by SUMMER93
  767. // Calls: 
  768. // Called By: QBPROMPT 
  769. local IRETURN, I
  770.  
  771. IRETURN := 0 
  772.  
  773. for I := 1 to len( CSTRING )
  774.     if substr( CSTRING, I, 1 )== CCHAR 
  775.         IRETURN := IRETURN + 1 
  776.     endif 
  777. next 
  778.  
  779. return IRETURN 
  780.  
  781. //******************************************************************
  782. function CEILING( NVALUE ) // Amended by SUMMER93
  783. // Calls: 
  784. // Called By: INVOUT 
  785. local IRETURN, I
  786.  
  787. IRETURN := 0 
  788.  
  789. IRETURN := int( NVALUE + 0.999 )
  790.  
  791. return IRETURN 
  792.  
  793. //******************************************************************
  794. function ISDRIVE( CDRIVE ) // Amended by SUMMER93
  795. // Calls: 
  796. // Called By: DRIVEOK 
  797.  
  798. return .t. 
  799.  
  800. //******************************************************************
  801. function ATNEXT( CCHAR, CSTRING, NOCC ) // Amended by SUMMER93
  802. // Calls: 
  803. // Called By: QBPROMPT QBTXTMAC 
  804. local IRETURN, I, ICOUNT
  805.  
  806. IRETURN := ICOUNT := 0 
  807.  
  808. begin sequence 
  809. for I := 1 to len( CSTRING )
  810.     if substr( CSTRING, I, 1 )== CCHAR 
  811.         IRETURN := I 
  812.         ICOUNT := ICOUNT + 1 
  813.         if ICOUNT >= NOCC 
  814.             break 
  815.         endif  // if iCount >= nOcc
  816.     endif  // if substr( cString, i, 1 ) == cChar
  817. next 
  818. IRETURN := 0 
  819. end 
  820. return IRETURN 
  821.  
  822. //******************************************************************
  823. function center( CSTRING, NWIDTH ) // Amended by SUMMER93
  824. // Calls: 
  825. // Called By: 
  826. local ILEN, CRETURN
  827.  
  828.  
  829. if valtype( nWidth ) <> "N" 
  830.     NWIDTH := 80 
  831. endif  // if type( "nWidth" ) <> "N"
  832. ILEN := int( (NWIDTH - len(alltrim(CSTRING ))) / 2 )
  833.  
  834. if ILEN < 0 
  835.     CRETURN := substr( CSTRING, 1, NWIDTH )
  836. else 
  837.     CRETURN := space( ILEN ) + alltrim( CSTRING )
  838. endif  // if iLen < 0
  839.  
  840. return CRETURN 
  841.  
  842. FUNCTION PDEST( xNewVal )
  843. local xReturn := PDEST
  844. if xNewVal <> NIL
  845.     PDEST := xNewVal
  846. endif
  847. return xReturn
  848. // End of file
  849.